HPAVC/HPAVC CD-ROM.iso/pc/PRUS101.ZIP/FDATE.PAS

Pascal/Delphi Source File | 1995-01-11 | 10.5 KB | 353 lines

UNIT FDATE; { FIDO unit for handling time, date(s) and calender(s) }
 (***************************************************************************

            RELEASE 1.03 - as contained in the file PRUS101.LZH
                by Peter Holschbach, 2:2450/660.3, GERMANY

               --------------------------------------------
                organized for Fido's PASCAL related echoes
               --------------------------------------------

     06/16/1994 to 06/18/1994 by Orazio Czerwenka, 2:2450/540.55, GERMANY
     06/18/1994 to --/--/---- by Peter Holschbach, 2:2450/660.3,  GERMANY


           As far as third party copyrights are not violated this
           source code is hereby placed to the public domain. Use
           it whatever way you want, but use AT YOUR OWN RISK.

           In case you should modify the source rather send your
           modifications to the unit's current organizer (see above for
           NM address) than to spread it on your own. This will help to
           keep the unit updated and grant a certain standard to all
           other users as well.

           The unit is currently still under work. So it might greatly
           benefit of your participation.

           Those who contributed to the following piece of source,
           listed in alphabethical order:
        ================================================================
           Orazio Czerwenka, Peter Holschbach ...
        ================================================================
           YOUR NAME WILL APPEAR HERE IF YOU CONTRIBUTE USEFUL SOURCE.

           Credits in your own programs are as welcome as unnecessary.

 ***************************************************************************)

{$I FDEFINE.DEF}

interface

const
  European      = 1;
  American      = 2;
  Japanese      = 3;
  TimeSeperator : Char = ':';
  DateSeperator : Char = '.';

  DateFormat    : Byte = European;

  CDaysOfMonth : Array [0..1] of Array [1..12] of Byte = (
                 (31,28,31,30,31,30,31,31,30,31,30,31),
                 (31,29,31,30,31,30,31,31,30,31,30,31)
                 );

  CDayOfWeekAmerican : Array [0..6] of String [3] =
                       ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');

  CMonthAmerican :     Array [1..12] of string[3] =
   ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');

  CDayOfWeekGerman  : Array [0..6] of String [3] =
                       ('Son','Mon','Die','Mit','Don','Fre','Sam');

  CMonthGerman      :  Array [1..12] of string[3] =
   ('Jan','Feb','Mär','Apr','Mai','Jun','Jul','Aug','Sep','Okt','Nov','Dez');


function  DayDiff (FYear,FMonth,FDay,TYear,TMonth,TDay : Word) : LongInt;
function  DayNumber (Year,Month,Day : Word):LongInt;
function  DayOfWeek (Year,Month,Day : Word):Byte;
Function  DayOfYear (Year,Month,Day : Word):Word;
function  GetCurrentDateString : String;
Procedure GetDate (Var Year,Month,Day,DayOfWeek : Word);
function  GetDateString (Year,Month,Day : Word) : String;
function  GetCurrentTimeString : String;
Procedure GetTime (Var Hour,Minute,Second,Sec100:Word);
function  GetTimeString (hour,minute,second : Word) : String;
Function  GetCurrentUnixTime : LongInt;
Function  GetUnixTime(Year,Month,Day,Hour,Minute,Second : Word) : LongInt;
function  IsLeapYear (Year : Word): Boolean;
function  ValidDate (Year,Month,Day : Word):Byte;
function  WeekOfYear (Year,Month,Day : Word):Byte;

implementation

(**************************************************************************)

function DayDiff (FYear,FMonth,FDay,TYear,TMonth,TDay : Word) : LongInt;

Begin
  DayDiff := DayNumber (TYear,TMonth,TDay) - DayNumber (FYear,FMonth,FDay);
End;

{----------------------------------------------------------------------------}

function DayNumber (Year,Month,Day : Word):LongInt;
{ Original author: Peter Holschbach }

Begin
  DayNumber := LongInt (Year-1) * 365 + (Year-1) div 4 - (Year-1) div 100 +
               (Year-1) div 400 + DayOfYear (Year,Month,Day);
               (* Days gone since 0000 *)
End;

{----------------------------------------------------------------------------}

function DayOfWeek (Year,Month,Day : Word):Byte;
{ Original author: Peter Holschbach }

Begin
  DayOfWeek := (DayNumber (Year,Month,Day) mod 7);
End;

{----------------------------------------------------------------------------}

Function DayOfYear (Year,Month,Day : Word):Word;
{ Original author: Peter Holschbach }

Var LeapYear : Byte;
    Days     : Word;
    L        : Byte;

Begin
  Days := 0;
  LeapYear := Byte(IsLeapYear (Year));
  For L:= 1 to Month-1 do Begin   (* count alle the days *)
    Days := Days + CDaysOfMonth [LeapYear,L];
  End;
  DayOfYear := Days + Day;  (* add the days of the month *)
End;

{----------------------------------------------------------------------------}
Function GetCurrentDateString : String;
{ Original author: Peter Holschbach,
  modifications Orazio Czerwenka }
var Year,
    Month,
    Day,
    DayOfWeek      : Word;

Begin
  GetDate (Year,Month,Day,DayOfWeek);
  GetCurrentDateString := GetDateString (Year,Month,Day);
End;

{----------------------------------------------------------------------------}
Procedure GetDate (Var Year,Month,Day,DayOfWeek: Word);
{ Original author: Peter Holschbach}

Begin
  Asm
    MOV AH,$2A   (* Get Date *)
    INT $21
    LES BX,Year
    MOV ES:[BX],CX
    XOR AH,AH        (* set AH to Zero *)
    LES BX,DayOfWeek
    MOV ES:[BX],AX
    LES BX,Month
    MOV AL,DH
    MOV ES:[BX],AX   (* is WORD ! *)
    LES BX,Day
    MOV AL,DL
    MOV ES:[BX],AX
  End;
End;

{----------------------------------------------------------------------------}

Function GetDateString (Year,Month,Day : Word): String;
{ Original author: Peter Holschbach}

var
    Tmp         : String;
    TmpDate     : String;
    L           : Word;

Begin
  Case DateFormat of
    European: begin Str (Day:2,TmpDate); Str (Month:2,Tmp); end;
    American: begin Str (Month:2,TmpDate); Str (Day:2,Tmp); end;
    Japanese: begin Str ((Year Mod 100):2,TmpDate); Str (Month:2,Tmp); end;
  End;
  TmpDate := TmpDate + DateSeperator + Tmp;
  Case DateFormat of
    European,
    American: Str ((Year Mod 100):2,Tmp);
    Japanese: Str (Day:2,Tmp);
  End;
  TmpDate := TmpDate + DateSeperator + Tmp;
  For L := 1 to Length (TmpDate) do Begin
    If TmpDate [L] = ' ' then TmpDate [L] := '0';
  End;
  GetDateString := TmpDate;
End;

{----------------------------------------------------------------------------}

Function GetCurrentTimeString : String;
{ Original author: Peter Holschbach}

var Hour,
    Minute,
    Second,
    Sec100: Word;


Begin
  GetTime (Hour,Minute,Second,Sec100);
  GetCurrentTimeString := GetTimeString (Hour,Minute,Second);
End;
{----------------------------------------------------------------------------}

Procedure GetTime (Var Hour,Minute,Second,Sec100:Word);
{ Original author: Peter Holschbach }

Begin
  Asm
    MOV AH,$2C   (* Get Time *)
    INT $21
    XOR AH,AH
    LES BX,Hour
    MOV AL,CH
    MOV ES:[BX],AX
    LES BX,Minute
    MOV AL,CL
    MOV ES:[BX],AX
    LES BX,Second
    MOV AL,DH
    MOV ES:[BX],AX
    LES BX,Sec100
    MOV AL,DL
    MOV ES:[BX],AX
  End;
end;

{----------------------------------------------------------------------------}

Function GetTimeString (hour,minute,second : Word) : String;
{ Original author: Peter Holschbach,
  modifications Orazio Czerwenka }
var
    Tmp         : String;
    TmpTime     : String;
    L           : Word;

Begin
  Str (Hour:2,TmpTime);
  Str (Minute:2,Tmp);
  TmpTime := TmpTime + TimeSeperator + Tmp;
  Str (Second:2,Tmp);
  TmpTime := TmpTime + TimeSeperator + Tmp;
  For L := 1 to Length (TmpTime) do Begin
    If TmpTime [L] = ' ' then TmpTime [L] := '0';
  End;
  GetTimeString := TmpTime;
End;

{----------------------------------------------------------------------------}

Function  GetCurrentUnixTime : LongInt;
{ Original author: Peter Holschbach }

var Year,
    Month,
    Day,
    DayOfWeek,
    Hour,
    Minute,
    Second,
    Sec100: Word;

Begin
  GetTime (Hour,Minute,Second,Sec100);
  GetDate (Year,Month,Day,DayOfWeek);
  GetCurrentUnixTime := GetUnixTime(Year,Month,Day,Hour,Minute,Second);
End;


{----------------------------------------------------------------------------}
Function  GetUnixTime(Year,Month,Day,Hour,Minute,Second : Word) : LongInt;
{ Original author: Peter Holschbach }

Var Days : LongInt;

Begin
  Days := DayDiff (1970,1,1,Year,Month,Day);
  GetUnixTime := LongInt(Days) * 24 * 60 * 60 + 60*60*LongInt(Hour) + 60*Minute + Second;
End;

{----------------------------------------------------------------------------}

function IsLeapYear (Year : Word): Boolean;
{ Original author: Peter Holschbach }

Begin
  IsLeapYear := ((Year Mod 4) = 0) AND ( (NOT((Year MOD 100) = 0)) OR
                                              ((Year MOD 400) = 0) );
End;

{----------------------------------------------------------------------------}

function  ValidDate (Year,Month,Day : Word):Byte;
{ Original author: Peter Holschbach}

Begin
  If (Month = 0) or (Month > 12) then Begin
    ValidDate := 2;
    Exit;
  End;
  If (Day = 0) or (Day < CDaysOfMonth [Byte(IsLeapYear (Year)),Month]) then Begin
    ValidDate := 3;
    Exit;
  End;
End;

{----------------------------------------------------------------------------}

function WeekOfYear (Year,Month,Day : Word):Byte;
{ Original author: Peter Holschbach}

        (* days to next monday/thuesday from any day of week *)
Const   CNextMon : Array [0..6] Of Byte = (1,0,6,5,4,3,2);
        CNextThu: Array [0..6] Of Byte = (4,3,2,1,0,6,5);

Var
    Week  : Integer;

Begin
    (* test if the year starts with the first week *)
  If CNextThu [DayOfWeek (Year,1,1)] > 3 then Begin
    week := (Integer(DayOfYear(Year,Month,Day)) - CNextMon [DayOfWeek (Year,1,1)] + 6) div 7;
  End
  Else Begin
    week := (Integer(DayOfYear(Year,Month,Day)) - CNextMon [DayOfWeek (Year,1,1)] + 6) div 7+1;
  End;
  If Week <= 0 then Begin
    (* the given date is in the last week of the previous year *)
    Week := WeekOfYear (year-1,12,31);
  End;
  WeekOfYear := Week;
End;

{----------------------------------------------------------------------------}
(**************************************************************************)

end.

1.02 -> 1.03
  - CMonthAmerican und CMonthGerman neu